home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / dbase / lib19.zip / SCA.PRG < prev    next >
Text File  |  1992-09-09  |  16KB  |  404 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: SCA.PRG
  3. *-- Programmer: Ken Mayer (KENMAYER)
  4. *-- Date......: 06/25/1992
  5. *-- Notes.....: This file contains the SCA Date handling routines, as well as a
  6. *--             copy of the roman numeral to arabic and vice-versa functions,
  7. *--             that are contained in CONVERT.PRG. This is due to the fact
  8. *--             that only two library files may be open at one time. See
  9. *--             the file README.TXT for more details on the use of this library
  10. *--             file.
  11. *-------------------------------------------------------------------------------
  12.  
  13. PROCEDURE SCA_Real
  14. *-------------------------------------------------------------------------------
  15. *-- Programmer..: Ken Mayer (Hirsch von Henford in the SCA) (KENMAYER)
  16. *-- Date........: 07/29/1991
  17. *-- Notes.......: This procedure was designed to handle data entered into
  18. *--               the Order of Precedence of the Principality of the Mists.
  19. *--               The problem is, my usual sources of data give only SCA
  20. *--               dates, and in order to sort properly, I need real dates.
  21. *--               This procedure will handle it, and goes hand-in-hand with
  22. *--               the function Real_SCA, to translate real dates to SCA
  23. *--               dates ... This procedure assumes that you have set the
  24. *--               F1 Key (see Example below). If you use a different F key,
  25. *--               you will want to modify the ON KEY LABEL commands ...
  26. *-- Written for.: dBASE IV, 1.1
  27. *-- Rev. History: 07/23/1991 - original procedure.
  28. *--               07/29/1991  -- modified it to stuff a character directly into
  29. *--               a date field (was having to do a CTOD in the program),
  30. *--               and added use of ESC to escape out, instead of killing
  31. *--               the procedure and the program calling it ...
  32. *-- Calls.......: CENTER               Procedure in PROC.PRG
  33. *--               SHADOW               Procedure in PROC.PRG
  34. *--               ARABIC()             Function in PROC.PRG
  35. *-- Called by...: Any
  36. *-- Usage.......: do SCA_Real
  37. *-- Example.....: on key label f1 do sca_real
  38. *--               store {} to t_date   && initialize as a date
  39. *--                                    && or you could STORE datefield to t_date
  40. *--                                    && if you have a date field ...
  41. *--               clear
  42. *--               @5,10 say "Enter a date:" get t_date;
  43. *--                  message "Press <F1> to convert from SCA date to real date"
  44. *--               read
  45. *--               on key label f1  && clear out that command ...
  46. *-- Returns.....: real date, forced into field ...
  47. *-- Parameters..: None
  48. *-------------------------------------------------------------------------------
  49.     
  50.     private cEscape,cExact,cYear,cMonth,cDay,nYearlen,nCount,nYear,nMonth
  51.     private nDay,cDate
  52.     
  53.     cEscape = set("ESCAPE")
  54.     set escape off            && so we can handle the Escape Key
  55.     cExact = set("EXACT")
  56.     set exact on              && VERY important ...
  57.     on key label F1 ?? chr(7) && make it beep, rather than call this procedure 
  58.                               && again, which causes wierdnesses ...
  59.     *-- first let's popup a window to ask for the information ...
  60.     
  61.     save screen to sDate
  62.     activate screen
  63.     define window wDate from 8,20 to 15,60 color rg+/gb,n/g,rg+/gb
  64.     do shadow with 8,20,15,60
  65.     activate window wDate
  66.     
  67.     *-- set the memvars ...
  68.     cYear  = space(8)
  69.     cMonth = space(3)
  70.     cDay   = space(2)
  71.     
  72.     do center with 0,40,"","Enter SCA Date below:"
  73.     do while .t.
  74.         
  75.         @2,14 say "Month: " get cMonth ;
  76.             picture "@M JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC";
  77.             message "Enter first letter of month, <Space> to scroll through, "+;
  78.                 "<Enter> to choose" color rg+/gb,n/g
  79.         @3,14 say "  Day: " get cDay picture "99";
  80.             message "Enter 2 digits for day of the month, if blank will assume 15";
  81.                 color rg+/gb,n/g
  82.         @4,14 say " Year: " get cYear picture "!!!!!!!!" ;
  83.             message "Enter year in AS roman numeral format";
  84.             valid required len(trim(cYear)) > 0;
  85.             error chr(7)+"This is no good without a year ..." color rg+/gb,n/g
  86.     
  87.         read
  88.     
  89.         if lastkey() = 27                && if user wants out by pressing <Esc>
  90.             deactivate window wDate
  91.             release window wDate
  92.             restore screen from sDate
  93.             release screen sDate
  94.             set escape &cEscape
  95.             set exact &cExact
  96.             on key label F1 do SCA_Real   && reset it ...
  97.             return
  98.         endif
  99.         
  100.         if lastkey() < 0   && function key F1 through Shift F9 was pressed
  101.             ?? chr(7)       && beep at user
  102.             loop            && don't let 'em get away with that -- try again
  103.         endif
  104.         
  105.         *-- check for valid roman numerals
  106.         cYear = trim(cYear)    && trim it
  107.         nYearLen = len(cYear)  && get length
  108.         nCount = 0            
  109.         do while nCount < nYearLen  && loop through length of year
  110.             nCount = nCount + 1      && increment
  111.             if .not. substr(cYear,nCount,1) $ "IVXLC" && if it's not here
  112.                 do center with 5,40,"rg+/r","** ERROR -- Invalid Year **"
  113.                 lError = .t.          && set error flag
  114.                 exit                  && exit internal loop
  115.             else
  116.                 lError = .f.          && make sure this is false
  117.             endif
  118.         enddo     && end of internal loop
  119.         if lError && if error,
  120.             loop   && go back ...
  121.         endif
  122.         
  123.         @5,0 clear   && clear out any error message ...
  124.         do center with 5,40,"rg+/r","Converting Date ..."
  125.         
  126.         *-- First (and most important) is conversion of the year
  127.         nYear = Arabic(cYear)
  128.         
  129.         *-- AS Years start at May ... if the month for a specific year is
  130.         *-- Jan through April it's part of the next "real" year ...
  131.         if cMonth = "JAN" .or. cMonth = "FEB" .or. cMonth = "MAR" .or.;
  132.                                        cMonth = "APR"
  133.             nYear = nYear + 1
  134.         endif
  135.         
  136.         nYear = nYear + 65  && SCA dates start at 66 ...
  137.         if nYear > 99       && this thing doesn't handle turn of the century
  138.             @5,0 clear
  139.             do center with 5,40,"rg+/r","No dates past XXXIV, please"
  140.             loop
  141.         endif
  142.         
  143.         *-- set numeric value of month ...
  144.         do case
  145.             case cMonth = "JAN"
  146.                 nMonth = 1
  147.             case cMonth = "FEB"
  148.                 nMonth = 2
  149.             case cMonth = "MAR"
  150.                 nMonth = 3
  151.             case cMonth = "APR"
  152.                 nMonth = 4
  153.             case cMonth = "MAY"
  154.                 nMonth = 5
  155.             case cMonth = "JUN"
  156.                 nMonth = 6
  157.             case cMonth = "JUL"
  158.                 nMonth = 7
  159.             case cMonth = "AUG"
  160.                 nMonth = 8
  161.             case cMonth = "SEP"
  162.                 nMonth = 9
  163.             case cMonth = "OCT"
  164.                 nMonth = 10
  165.             case cMonth = "NOV"
  166.                 nMonth = 11
  167.             case cMonth = "DEC"
  168.                 nMonth = 12
  169.         endcase
  170.         
  171.         *-- if the day field is empty, assume the middle of the month, so we
  172.         *-- have SOMETHING to go by ...
  173.         if len(alltrim(cDay)) = 0
  174.             nDay = 15
  175.         else
  176.             nDay = val(cDay)
  177.         endif
  178.         
  179.         *-- Check for valid day of the month ...
  180.         if nDay > 29 .and. nMonth = 2 .or. (nDay = 31 .and. (nMonth = 4 .or.;
  181.                                  nMonth = 6 .or. nMonth = 9 .or. nMonth = 11))
  182.             do center with 5,40,"rg+/r",chr(7)+"INVALID DATE -- Try again ..."
  183.             loop
  184.         endif
  185.         
  186.         exit                        && out of loop -- if here, we're done
  187.         
  188.     enddo                          && end of loop
  189.  
  190.     *-- Convert it
  191.     cDate = transform(nMonth,"@L 99")+transform(nDay,"@L 99")+;
  192.               transform(nYear,"@L 99")
  193.     
  194.     *-- force this 'character' date into the date field on the screen ...
  195.     keyboard cDate clear           && put it into the field, and clear out
  196.                                    && keyboard buffer first ...
  197.  
  198.     *-- deal with cleanup ...
  199.     deac wind wDate
  200.     release wind wDate
  201.     restore screen from sDate
  202.     release screen sDate
  203.     set escape &cEscape
  204.     set exact &cExact
  205.     on key label F1 do SCA_Real  && reset for user
  206.     
  207. RETURN
  208. *-- EoP: SCA_Real
  209.  
  210. FUNCTION SCA2Real
  211. *-------------------------------------------------------------------------------
  212. *-- Programmer..: Jay Parsons (JPARSONS)
  213. *-- Date........: 04/22/1992
  214. *-- Notes.......: Jay figured out a short version of SCA_Real above, which
  215. *--               does not use screen input/screen display. This can be used
  216. *--               directly as a function.
  217. *-- Written for.: dBASE IV, 1.5
  218. *-- Rev. History: None
  219. *-- Calls.......: ALLTRIM()